;;############################################################################
;; mosaic3.lsp
;; Copyright (c) 1998 by Forrest W. Young & Ernest Kwan
;; Code to implement mosaic plot object prototype.
;; Mosaic drawing algorithm by Ernest Kwan
;;
;; File contains code to fill tiles with subplots 
;; and to add color spectrum and grid
;;
;; Also contains PV code to correct cell position bug
;;
;;############################################################################



(defmeth mosaic-proto :chi-sq-contributions-for-mosaic-freq-table (cells levels)
"calculates matrix of chi-sq contributions for each cell of the one or two-way frequency table displayed as a mosaic (where the table's rows and columns are formed from combinations of indices when the frequency array is 3 or 4 way)"
  (let* ((freq-array (make-array levels :initial-contents cells))
         (nways (length levels))
         (n0 (array-dimension freq-array 0))
         (n1 (if (= 4 nways) (array-dimension freq-array 1) nil))
         (freq-table
          (case nways
            (1 freq-array)
            (2 freq-array)
            (3 (apply #'bind-columns 
                      (mapcar #'(lambda (i) 
                                   (extract-array freq-array (list i ! !)))
                       (iseq n0))))
            (4 (apply #'bind-columns
                      (mapcar #'(lambda (j)
                                  (mapcar #'(lambda (i) 
                                              (extract-array freq-array (list i j ! !)))
                                          (iseq n0)))
                              (iseq n1))))
            )))
    (chi-sq-contributions freq-table)))
         


(defmeth mosaic-proto :chi-sq-contributions (cells levels)
"calculates matrix of chi-sq contributions from additivity hypothesis for the array represented by the mosaic"
  (chi-sq-contributions cells levels))

 (defmeth  mosaic-proto :correct-position-cells (&optional level-labels)
"Corrects the position of the cells so the ordering of computation of mosaic cells is first
even variables in order of entry and then odds. This is part of using columns proportional.
PV"

   (let* ((level-labels (if level-labels level-labels (send self :level-labels)))
          (ways (length level-labels))
          (levels (mapcar 'length level-labels))
          
          (numlabels (cumsum levels))
          
          (level-labels 
           (mapcar #'(lambda (i) 
                       (if (= i 0)
                           (iseq (select numlabels i))
                           (iseq (select numlabels (1- i)) (1- (select numlabels i)))))
                   (iseq (length numlabels))))
          (result (first level-labels))
          (rest (select level-labels (remove '0 (iseq ways))))
          ; (rest (if (= ways 3) (reverse rest) rest))
          (normal-list 
           (mapcar #'(lambda(l) 
                       (setf result (string-list l result )))
                   rest))
          (result2 (first level-labels))
          (rest2 (append 
                  (butfirst
                   (select level-labels
                           (which (mapcar 'evenp (iseq ways)))))
                  (select level-labels
                          (which (mapcar 'oddp (iseq ways))))))
          
          ;(rest2 (if (= ways 3) (reverse rest2) rest2))       
          (changed-list (mapcar #'(lambda(l) 
                                    (setf result2 (string-list  l result2)))
                                rest2))
          (final (mapcar #'(lambda (res) (position res (if (= ways 1)
                                                           result
                                                           (mapcar 'sort-data result))
                                                   :test 'equal))
                          
                         (if (= ways 1)
                             result2
                             (mapcar 'sort-data result2)))))
     final))


(defmeth mosaic-proto :fill-tiles ()     
  (let* (
         (loc (send self :location))
         (choice (choose-item-dialog 
                  "Choose Type of Plot for Cells" 
                  (list (if (send self :shading) "Coloring" "None") 
                        "Dot Plots" "Random Points" 
                        "Quantile Curve" "Normal Probability Curve")
                  :location (+ loc '(40 40)))))
    (when choice 
          (send self :start-buffering)
          (send self :make-subplots choice)
          (send self :buffer-to-screen))))

(defmeth mosaic-proto :make-subplots (choice)
  (send self :clear)
  (send self :original-mx (coerce (send self :content-rect) 'vector))
  (send self :prepare)
  (send self :range 0 0 100)
  (send self :range 1 0 100)
  (send self :add-mosaic)
  (send self :resize)
  (if (and (send self :shading) (= choice 0))
      (send self :colored-tiles t)
      (send self :colored-tiles nil))
  (case choice
    (0 (send self :plottype nil)) 
    (1 (send self :plottype "dotplot")
       (send self :fill "valueplot")
       (send self :add-dotplot :color 'blue))
    (2 (send self :plottype "random")
       (send self :fill "randplot")
       (send self :add-random-points :color 'blue))
    (3 (send self :plottype "qplot")
       (send self :fill "valueplot")
       (send self :add-qornpplot nil :color 'blue))
    (4 (send self :plottype "npplot")
       (send self :fill "valueplot")
       (send self :add-qornpplot t :color 'blue))
    )
  (send self :redraw)
  )


(defmeth mosaic-proto :add-random-points (&key (color 'black))
  (let* ((draw-mx (send self :draw-mx))
         (total (send self :total))
         (scaled-rect) (npt) (x) (y))
    (send self :clear-points)
    (when draw-mx
          (dotimes (i total)
                   (setf npt (select (send self :cells) i))
                   (setf scaled-rect 
                         (send self :make-tiles 
                               (aref draw-mx i 0)
                               (aref draw-mx i 1)
                               (aref draw-mx i 2)
                               (aref draw-mx i 3) :draw nil))
                   (setf x (round (+ (elt scaled-rect 0) (* .05 (elt scaled-rect 2))
                                     (* .9 (elt scaled-rect 2) (uniform-rand npt)))))
                   (setf y (round (+ (elt scaled-rect 1) (* .05 (elt scaled-rect 3))
                                     (* .9 (elt scaled-rect 3) (uniform-rand npt)))))
                   (send self :add-points (list x y) :color color))
          (send self :point-label (iseq (send self :num-points)) 
                (repeat " " (send self :num-points)))
          )))

(defmeth mosaic-proto :add-dotplot (&key (color 'black))
  (let* ((point-labels (send self :point-labels))
         (draw-mx (send self :draw-mx))
         (total (send self :total))
         (plotvalues (send self :plotvalues))
         (maxes (mapcar #'max plotvalues))
         (mins  (mapcar #'min plotvalues))
         (plotvalues (/ (+ .0005 (- plotvalues mins))
                       (+ .001 (- maxes mins))))
         (scaled-rect) (npt) (x) (y) )
    (send self :clear-points)
    (when draw-mx
          (dotimes (i total)
                   (setf npt (select (send self :cells) i))
                   (setf scaled-rect 
                         (send self :make-tiles 
                               (aref draw-mx i 0)
                               (aref draw-mx i 1)
                               (aref draw-mx i 2)
                               (aref draw-mx i 3) :draw nil));(break)
                   (setf x (round (+ (elt scaled-rect 0) 
                                            (* .05 (elt scaled-rect 2))
                                            (* .9 (elt scaled-rect 2) 
                                               (repeat .5 npt)))))
                   (setf y (round (+ (elt scaled-rect 1) 
                                            (* .05 (elt scaled-rect 3))
                                            (* .9 (elt scaled-rect 3) 
                                               (- 1 (elt plotvalues i))))))  
                   (send self :add-points (list x y) :color color)
                   ))))


(defmeth mosaic-proto :add-qornpplot (np &key (color 'black))
  (let* ((draw-mx (send self :draw-mx))
         (total (send self :total))
         (plotvalues (send self :plotvalues))
         (maxes (mapcar #'max plotvalues))
         (mins  (mapcar #'min plotvalues))
         (plotvalues (/ (+ .0005 (- plotvalues mins) )
                      (+ .001 (- maxes mins))))
         (scaled-rect) (npt) (x) (y) (nqx) (minnqx) (maxnqx))
    (send self :clear-points)
    (when draw-mx
          (dotimes (i total)
                   (setf npt (select (send self :cells) i))
                   (when (> npt 1)
                         (setf scaled-rect 
                               (send self :make-tiles 
                                     (aref draw-mx i 0)
                                     (aref draw-mx i 1)
                                     (aref draw-mx i 2)
                                     (aref draw-mx i 3) :draw nil))
                         (setf y (sort-data (- 1 (elt plotvalues i))))
                         (setf x (reverse (sort-data (/ (1+ (rank y)) 
                                                        (1+ (length y))))))
                         (when np 
                               (setf nqx (normal-quant x))
                               (setf minnqx (min nqx))
                               (setf maxnqx (max nqx))
                               (setf x (/ (+ .0005 (- nqx minnqx)) 
                                          (+ .001 (- maxnqx minnqx)))))
                         (setf x (round (+ (elt scaled-rect 0) 
                                           (* .05 (elt scaled-rect 2))
                                           (* .9 (elt scaled-rect 2) x))))
                         (setf y (round (+ (elt scaled-rect 1) 
                                           (* .05 (elt scaled-rect 3))
                                           (* .9 (elt scaled-rect 3) y))))
                         (send self :add-lines (list x y) :color color))))))


(defmeth mosaic-proto :add-grid ()
  (let* ((rangex (send self :range 0))
         (rangey (send self :range 1))
         (minx (first  rangex))
         (maxx (second rangex))
         (miny (first  rangey))
         (maxy (second rangey))
         (line1start (- (send self :real-to-canvas minx maxy) '(5 5)))
         (line1end   (- (send self :real-to-canvas maxx maxy) '(0 5)))
         (line2start (send self :real-to-canvas maxx miny))
         (line2end   (- (send self :real-to-canvas maxx maxy) '(0 5)))
         (line3start (send self :real-to-canvas maxx miny))
         (line3end   (- (send self :real-to-canvas minx miny) '(5 0)))
         )
    (when (and line1start line1end line2start line2end)
          (apply #'send self :draw-line 
                 (combine line1start line1end))
          (apply #'send self :draw-line 
                 (combine line2start line2end))
          (apply #'send self :draw-line 
                 (combine line3start line3end))
          (apply #'send self :draw-line 
                 (combine line1start line3end))
          )))

(defmeth mosaic-proto :add-color-spectrum ()
  (let* ((rangex (send self :range 0))
         (rangey (send self :range 1))
         (maxx (second rangex))
         (miny (first  rangey))
         (maxy (second rangey))
         (rngy (- maxy miny))
         (recy (/ rngy 51))
         (topy (second (send self :real-to-canvas maxx maxy)))
         (botyritx (send self :real-to-canvas maxx miny))
         (boty (second botyritx))
         (ritx (+ 8 (first  botyritx)))
         (nrects (+ 1 (* 2 25)))
         (dc (send self :draw-color))
         (tw (+ (send self :text-ascent) (send self :text-descent) 2))
         (ydiff) (y1) (y2) (xycanvas) (ycanvas) (shade) (value)
         (shade-list)
         (legend (if (send self :use-color) "Color Key" "Shade Key"))
         )
    
    (dotimes (i nrects)
             (setf y1 (+ miny (* i recy)))
             (setf xycanvas (send self :real-to-canvas maxx y1))
             (setf ycanvas (second xycanvas))
             (setf y2 (+ miny (* (+ 1 i) recy)))
             (setf xycanvas (send self :real-to-canvas maxx y2))
             (setf ydiff (- (second xycanvas) ycanvas))
             (setf shade (* 2 (/ (- (/ (- nrects 1) 2) i) nrects)))
             (setf value (send self :color-function shade))
             (if (> shade 0)
                 (setf shade-list (list 1 value value)) ;(list 1 value value)
                 (setf shade-list (list value value 1)));(list value 1 value)
             (apply #'make-color 'fillit shade-list)
             (send self :draw-color 'fillit)
             (send self :paint-rect ritx ycanvas 10 ydiff))
    (send self :draw-color dc)
    (send self :frame-rect ritx topy 10 (- boty topy))
    (send self :draw-text-up "-3" (+ ritx 12) boty 1 1)
    (send self :draw-text-up "+3" (+ ritx 12) topy 1 1)
    (send self :draw-text-up legend (+ ritx 12) 
          (floor (+ (/ (- boty topy) 2) topy)) 1 1)
    (dotimes (i 5)
            (send self :draw-line 
                  (+ ritx 10) (+ topy (* (1+ i) (round (+ (/ (- boty topy) 6)))))
                  (+ ritx 13) (+ topy (* (1+ i) (round (+ (/ (- boty topy) 6)))))))
    ))

(defmeth mosaic-proto :plot-help (&key (flush t)) 
  (let ((overlay (first (send self :slot-value (quote overlays))))
        (w))
    (setf w (plot-help-window (strcat "Help for Mosaic Plots") :flush flush))
    (paste-plot-help (format nil  "MOSAIC PLOTS (AND BAR GRAPHS)~2%A mosaic plot shows the frequencies in an n-way table by nested rectangular regions whose area is proportional to the frequency in a cell or marginal subtable. The display uses color and shading to represent the sign and magnitude of standardized residuals from a specified model.~2%") w)
(paste-plot-help (format nil "Comparison of Mosaic Plots and Bar Graphs~%A mosaic plot presents the same information as is presented by a stacked bar-graph: The frequencies of combinations of categories of two variables.~%1.A mosaic plot consists of rectangles laid out in a mosaic. The rectangles are like the sub-bars in a stacked bar-graph.~%2.In a mosaic plot, each column of rectangles represents a category of the variable on the horizontal axis.~%3.In a stacked bar-graph, each bar represents the overall frequency of a category of the variable plotted on the horizontal axis. In a mosaic, the several column of tiles are all the same height, representing 100%. Thus each tile in a mosaic represents a proportional frequency of a category combination.~%4.Whereas a stacked bar-graph's sub-bars representing the joint frequency of a category of each of the two variables, in a mosaic plot each rectangle represents the joint probability of a category of each of the two variables.") w)
(show-plot-help)))
   